home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / prim / cmdloop.el < prev    next >
Encoding:
Text File  |  1995-08-26  |  17.9 KB  |  463 lines
  1. ;;; cmdloop.el --- support functions for the top-level command loop.
  2.  
  3. ;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
  4.  
  5. ;; This file is part of XEmacs.
  6.  
  7. ;; XEmacs is free software; you can redistribute it and/or modify it
  8. ;; under the terms of the GNU General Public License as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11.  
  12. ;; XEmacs is distributed in the hope that it will be useful, but
  13. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;; General Public License for more details.
  16.  
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  19. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21. ;;; Synched up with: FSF 19.28. (Some of the stuff below is in FSF's subr.el.)
  22.  
  23. ;; Written by Richard Mlynarik 8-Jul-92
  24.  
  25. (defun recursion-depth ()
  26.   "Return the current depth in recursive edits."
  27.   (+ command-loop-level (minibuffer-depth)))
  28.  
  29. (defun top-level ()
  30.   "Exit all recursive editing levels."
  31.   (interactive)
  32.   (throw 'top-level nil))
  33.  
  34. (defun exit-recursive-edit ()
  35.   "Exit from the innermost recursive edit or minibuffer."
  36.   (interactive)
  37.   (if (> (recursion-depth) 0)
  38.       (throw 'exit nil))
  39.   (error "No recursive edit is in progress"))
  40.  
  41. (defun abort-recursive-edit ()
  42.   "Abort the command that requested this recursive edit or minibuffer input."
  43.   (interactive)
  44.   (if (> (recursion-depth) 0)
  45.       (throw 'exit t))
  46.   (error "No recursive edit is in progress"))
  47.  
  48. ;; (defun keyboard-quit ()
  49. ;;   "Signal a `quit' condition."
  50. ;;   (interactive)
  51. ;;   (signal 'quit nil))
  52.  
  53. ;; moved here from pending-del.
  54. (defun keyboard-quit ()
  55.   "Signal a `quit' condition.
  56. If this character is typed while lisp code is executing, it will be treated
  57.  as an interrupt.
  58. If this character is typed at top-level, this simply beeps.
  59. If `zmacs-regions' is true, and the zmacs region is active, then this
  60.  key deactivates the region without beeping or signalling."
  61.   (interactive)
  62.   (if (and zmacs-regions (zmacs-deactivate-region))
  63.       ;; pseudo-zmacs compatibility: don't beep if this ^G is simply
  64.       ;; deactivating the region.  If it is inactive, beep.
  65.       nil
  66.     (signal 'quit nil)))
  67.  
  68. ;;#### This should really be a ring of last errors.
  69. ;;#### Better, there should -really- be a ring of last-echo-area-messages,
  70. ;;####  so that users can look back at ones they missed!!!!
  71. (defvar last-error nil
  72.   "#### Document me.")
  73.  
  74. (defun command-error (error-object)
  75.   (let ((inhibit-quit t)
  76.     (debug-on-error nil)
  77.     (etype (car-safe error-object)))
  78.     (setq quit-flag nil)
  79.     (setq standard-output t)
  80.     (setq standard-input t)
  81.     (setq executing-macro nil)
  82.     (zmacs-deactivate-region)
  83.     (discard-input)
  84.  
  85.     (setq last-error error-object)
  86.  
  87.     (message nil)
  88.     (ding nil (cond ((eq etype 'undefined-keystroke-sequence)
  89.              (if (and (vectorp (nth 1 error-object))
  90.                   (/= 0 (length (nth 1 error-object)))
  91.                   (button-event-p (aref (nth 1 error-object) 0)))
  92.              'undefined-click
  93.                'undefined-key))
  94.             ((eq etype 'quit)
  95.              'quit)
  96.             ((memq etype '(end-of-buffer beginning-of-buffer))
  97.              'buffer-bound)
  98.             ((eq etype 'buffer-read-only)
  99.              'read-only)
  100.             (t 'command-error)))
  101.     (display-error error-object t)
  102.  
  103.     (if (noninteractive)
  104.         (progn
  105.           (message "XEmacs exiting.")
  106.           (kill-emacs -1)))
  107.     t))
  108.  
  109. (defun describe-last-error ()
  110.   "Redisplay the last error-message.  See the variable `last-error'."
  111.   (interactive)
  112.   (with-output-to-temp-buffer "*Help*"
  113.     (princ "Last error was:\n" standard-output)
  114.     (display-error last-error standard-output)))
  115.  
  116.  
  117. ;;#### Must be done later in the loadup sequence
  118. ;(define-key (symbol-function 'help-command) "e" 'describe-last-error)
  119.  
  120.  
  121. (defun truncate-command-history-for-gc ()
  122.   (let ((tail (nthcdr 30 command-history)))
  123.     (if tail (setcdr tail nil)))
  124.   (let ((tail (nthcdr 30 values)))
  125.     (if tail (setcdr tail nil)))
  126.   )
  127.  
  128. (add-hook 'pre-gc-hook 'truncate-command-history-for-gc)
  129.  
  130.  
  131. ;;;; Object-oriented programming at its finest
  132.  
  133. (defun display-error (error-object stream) ;(defgeneric report-condition ...)
  134.   "Display `error-object' on `stream' in a user-friendly way."
  135.   (funcall (or (let ((type (car-safe error-object)))
  136.                  (catch 'error
  137.                    (and (consp error-object)
  138.                         (symbolp type)
  139.                         ;;(stringp (get type 'error-message))
  140.             (consp (get type 'error-conditions))
  141.                         (let ((tail (cdr error-object)))
  142.                           (while (not (null tail))
  143.                             (if (consp tail)
  144.                                 (setq tail (cdr tail))
  145.                                 (throw 'error nil)))
  146.                           t)
  147.                         ;; (check-type condition condition)
  148.                         (get type 'error-conditions)
  149.                         ;; Search class hierarchy
  150.                         (let ((tail (get type 'error-conditions)))
  151.                           (while (not (null tail))
  152.                             (cond ((not (and (consp tail)
  153.                                              (symbolp (car tail))))
  154.                                    (throw 'error nil))
  155.                                   ((get (car tail) 'display-error)
  156.                                    (throw 'error (get (car tail)
  157.                                                       'display-error)))
  158.                                   (t
  159.                                    (setq tail (cdr tail)))))
  160.                           ;; Default method
  161.                           #'(lambda (error-object stream)
  162.                               (let ((type (car error-object))
  163.                                     (tail (cdr error-object))
  164.                                     (first t)
  165.                     (print-message-label 'error))
  166.                                 (if (eq type 'error)
  167.                                     (progn (princ (car tail) stream)
  168.                                            (setq tail (cdr tail)))
  169.                   (princ (or (gettext (get type 'error-message)) type)
  170.                      stream))
  171.                                 (while tail
  172.                                   (princ (if first ": " ", ") stream)
  173.                                   (prin1 (car tail) stream)
  174.                                   (setq tail (cdr tail)
  175.                                         first nil))))))))
  176.            #'(lambda (error-object stream)
  177.                    (princ (gettext "Peculiar error ") stream)
  178.                    (prin1 error-object stream)))
  179.            error-object stream))
  180.  
  181. (put 'file-error 'display-error
  182.      #'(lambda (error-object stream)
  183.          (let ((tail (cdr error-object))
  184.                (first t))
  185.            (princ (car tail) stream)
  186.            (while (setq tail (cdr tail))
  187.              (princ (if first ": " ", ") stream)
  188.              (princ (car tail) stream)
  189.              (setq first nil)))))
  190.  
  191. (put 'undefined-keystroke-sequence 'display-error
  192.      #'(lambda (error-object stream)
  193.          (princ (key-description (car (cdr error-object))) stream)
  194.      ;; #### I18N3: doesn't localize properly.
  195.          (princ (gettext " not defined.") stream) ; doo dah, doo dah.
  196.          ))
  197.  
  198.  
  199. (defvar teach-extended-commands-p t
  200.   "*If true, then `\\[execute-extended-command]' will teach you keybindings.
  201. Any time you execute a command with \\[execute-extended-command] which has a
  202. shorter keybinding, you will be shown the alternate binding before the
  203. command executes.")
  204.  
  205. (defvar teach-extended-commands-timeout 2
  206.   "*How long to pause after displaying a keybinding before executing.
  207. This only applies if `teach-extended-commands-p' is true.")
  208.  
  209. (defun execute-extended-command (prefix-arg)
  210.   "Read a command name from the minibuffer using 'completing-read'.
  211. Then call the specified command using 'command-execute' and return its
  212. return value.  If the command asks for a prefix argument, supply the
  213. value of the current raw prefix argument, or the value of PREFIX-ARG
  214. when called from Lisp."
  215.   (interactive "P")
  216.   ;; Note:  This doesn't hack "this-command-keys"
  217.   (let ((prefix-arg prefix-arg))
  218.     (setq this-command (read-command
  219.                         ;; Note: this has the hard-wired
  220.                         ;;  "C-u" and "M-x" string bug in common
  221.                         ;;  with all GNU Emacs's.
  222.             ;; (#### someone please explain?)
  223.                         (cond ((eq prefix-arg '-)
  224.                                "- M-x ")
  225.                               ((equal prefix-arg '(4))
  226.                                "C-u M-x ")
  227.                               ((integerp prefix-arg)
  228.                                (format "%d M-x " prefix-arg))
  229.                               ((and (consp prefix-arg)
  230.                                     (integerp (car prefix-arg)))
  231.                                (format "%d M-x " (car prefix-arg)))
  232.                               (t
  233.                                "M-x ")))))
  234.  
  235.   (if (and teach-extended-commands-p (interactive-p))
  236.       (let ((keys (where-is-internal this-command)))
  237.     (if keys
  238.         (progn
  239.           (message "M-x %s (bound to key%s: %s)"
  240.                this-command
  241.                (if (cdr keys) "s" "")
  242.                (mapconcat 'key-description
  243.                   (sort keys #'(lambda (x y)
  244.                          (< (length x) (length y))))
  245.                   ", "))
  246.           (sit-for teach-extended-commands-timeout)))))
  247.  
  248.   (command-execute this-command t))
  249.  
  250.  
  251. ;;; C code calls this; the underscores in the variable names are to avoid
  252. ;;; cluttering the specbind namespace (lexical scope!  lexical scope!)
  253. ;;; Putting this in Lisp instead of C slows kbd macros by 50%.
  254. ;(defun command-execute (_command &optional _record-flag)
  255. ;  "Execute CMD as an editor command.
  256. ;CMD must be a symbol that satisfies the `commandp' predicate.
  257. ;Optional second arg RECORD-FLAG non-nil
  258. ;means unconditionally put this command in `command-history'.
  259. ;Otherwise, that is done only if an arg is read using the minibuffer."
  260. ;  (let ((_prefix prefix-arg)
  261. ;        (_cmd (indirect-function _command)))
  262. ;    (setq prefix-arg nil
  263. ;          this-command _command
  264. ;          current-prefix-arg _prefix
  265. ;          zmacs-region-stays nil)
  266. ;    ;; #### debug_on_next_call = 0;
  267. ;    (cond ((and (symbolp _command)
  268. ;                (get _command 'disabled))
  269. ;           (run-hooks disabled-command-hook))
  270. ;          ((or (stringp _cmd) (vectorp _cmd))
  271. ;           ;; If requested, place the macro in the command history.  
  272. ;           ;;  For other sorts of commands, call-interactively takes
  273. ;           ;;  care of this. 
  274. ;           (if _record-flag
  275. ;               (setq command-history
  276. ;                     (cons (list 'execute-kbd-macro _cmd _prefix)
  277. ;                           command-history)))
  278. ;             (execute-kbd-macro _cmd _prefix))
  279. ;            (t
  280. ;             (call-interactively _command _record-flag)))))
  281.  
  282. (defun y-or-n-p-minibuf (prompt)
  283.   "Ask user a \"y or n\" question.  Return t if answer is \"y\".
  284. Takes one argument, which is the string to display to ask the question.
  285. It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
  286. No confirmation of the answer is requested; a single character is enough.
  287. Also accepts Space to mean yes, or Delete to mean no."
  288.   (save-excursion
  289.     (let* ((pre "")
  290.            (yn (gettext "(y or n) "))
  291.        ;; we need to translate the prompt ourselves because of the
  292.        ;; strange way we handle it.
  293.        (prompt (gettext prompt))
  294.            event)
  295.       (while (stringp yn)
  296.         (if (let ((cursor-in-echo-area t)
  297.                   (inhibit-quit t))
  298.               (message "%s%s%s" pre prompt yn)
  299.               (setq event (next-command-event event))
  300.               (prog1
  301.           (or quit-flag (eq 'keyboard-quit (key-binding event)))
  302.         (setq quit-flag nil)))
  303.             (progn
  304.               (message "%s%s%s%s" pre prompt yn (single-key-description event))
  305.               (setq quit-flag nil)
  306.               (signal 'quit '())))
  307.         (let* ((key (and (key-press-event-p event) (event-key event)))
  308.                (char (and key (event-to-character event))))
  309.           (if char (setq char (downcase char)))
  310.           (cond ((or (eq char ?y) (eq char ? ))
  311.                  (message "%s%sYes" prompt yn)
  312.                  (setq yn t))
  313.                 ((or (eq char ?n) (eq key 'delete))
  314.                  (message "%s%sNo" prompt yn)
  315.                  (setq yn nil))
  316.                 ((button-release-event-p event) ; ignore them
  317.                  nil)
  318.                 (t
  319.                  (message "%s%s%s%s" pre prompt yn
  320.                           (single-key-description event))
  321.                  (ding nil 'y-or-n-p)
  322.                  (discard-input)
  323.                  (if (= (length pre) 0)
  324.                      (setq pre (gettext "Please answer y or n.  ")))))))
  325.       yn)))
  326.  
  327. (defun yes-or-no-p-minibuf (prompt)
  328.   "Ask user a yes-or-no question.  Return t if answer is yes.
  329. Takes one argument, which is the string to display to ask the question.
  330. It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
  331. The user must confirm the answer with RET,
  332. and can edit it until it has been confirmed."
  333.   (save-excursion
  334.     (let ((p (concat (gettext prompt) (gettext "(yes or no) ")))
  335.           (ans ""))
  336.       (while (stringp ans)
  337.         (setq ans (downcase (read-string p nil t))) ;no history
  338.         (cond ((string-equal ans (gettext "yes"))
  339.                (setq ans 't))
  340.               ((string-equal ans (gettext "no"))
  341.                (setq ans 'nil))
  342.               (t
  343.                (ding nil 'yes-or-no-p)
  344.                (discard-input)
  345.                (message "Please answer yes or no.")
  346.                (sleep-for 2))))
  347.       ans)))
  348.  
  349. ;; these may be redefined later, but make the original def easily encapsulable
  350. (define-function 'yes-or-no-p 'yes-or-no-p-minibuf)
  351. (define-function 'y-or-n-p 'y-or-n-p-minibuf)
  352.  
  353.  
  354. (defun read-char ()
  355.   "Read a character from the command input (keyboard or macro).
  356. If a mouse click or non-ASCII character is detected, an error is
  357. signalled.  The character typed is returned as an ASCII value.  This
  358. is most likely the wrong thing for you to be using: consider using
  359. the `next-command-event' function instead."
  360.   (save-excursion
  361.     (let ((inhibit-quit t)
  362.           (event (next-command-event)))
  363.       (prog1 (or (event-to-character event)
  364.                  ;; Kludge.  If the event we read was a mouse-release,
  365.                  ;; discard it and read the next one.
  366.                  (if (button-release-event-p event)
  367.                      (event-to-character (next-command-event event)))
  368.                  (error "Key read has no ASCII equivalent %S" event))
  369.         ;; this is not necessary, but is marginally more efficient than GC.
  370.         (deallocate-event event)))))
  371.  
  372. (defun read-char-exclusive ()
  373.   "Read a character from the command input (keyboard or macro).
  374. If a mouse click or non-ASCII character is detected, it is discarded.
  375. The character typed is returned as an ASCII value.  This is most likely
  376. the wrong thing for you to be using: consider using the
  377. `next-command-event' function instead."
  378.   (let ((inhibit-quit t)
  379.     event ch)
  380.     (while (progn
  381.          (setq event (next-command-event))
  382.          (setq ch (event-to-character event))
  383.          (deallocate-event event)
  384.          (null ch)))
  385.     ch))
  386.  
  387. (defun read-quoted-char (&optional prompt)
  388.   "Like `read-char', except that if the first character read is an octal
  389. digit, we read up to two more octal digits and return the character
  390. represented by the octal number consisting of those digits.
  391. Optional argument PROMPT specifies a string to use to prompt the user."
  392.   (save-excursion
  393.     (let ((count 0) (code 0)
  394.       (prompt (and prompt (gettext prompt)))
  395.       char event)
  396.       (while (< count 3)
  397.         (let ((inhibit-quit (zerop count))
  398.               (help-form nil))
  399.           (and prompt (message "%s-" prompt))
  400.           (setq event (next-command-event)
  401.                 char (or (event-to-character event nil nil t)
  402.                          (error "key read cannot be inserted in a buffer: %S"
  403.                           event)))
  404.           (if inhibit-quit (setq quit-flag nil)))
  405.         (cond ((null char))
  406.               ((and (<= ?0 char) (<= char ?7))
  407.                (setq code (+ (* code 8) (- char ?0))
  408.                      count (1+ count))
  409.                (and prompt (message (setq prompt
  410.                                           (format "%s %c" prompt char)))))
  411.               ((> count 0)
  412.                (setq unread-command-event event
  413.                      count 259))
  414.               (t (setq code char count 259))))
  415.     ;; Turn a meta-character into a character with the 0200 bit set.
  416.     (logior (if (/= (logand code (lsh 1 23)) 0) 128 0)
  417.         (logand 255 code)))))
  418.  
  419. (defun momentary-string-display (string pos &optional exit-char message) 
  420.   "Momentarily display STRING in the buffer at POS.
  421. Display remains until next character is typed.
  422. If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed;
  423. otherwise it is then available as input (as a command if nothing else).
  424. Display MESSAGE (optional fourth arg) in the echo area.
  425. If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
  426.   (or exit-char (setq exit-char ?\ ))
  427.   (let ((buffer-read-only nil)
  428.     ;; Don't modify the undo list at all.
  429.     (buffer-undo-list t)
  430.     (modified (buffer-modified-p))
  431.     (name buffer-file-name)
  432.     insert-end)
  433.     (unwind-protect
  434.     (progn
  435.       (save-excursion
  436.         (goto-char pos)
  437.         ;; defeat file locking... don't try this at home, kids!
  438.         (setq buffer-file-name nil)
  439.         (insert-before-markers (gettext string))
  440.         (setq insert-end (point))
  441.         ;; If the message end is off frame, recenter now.
  442.         (if (> (window-end) insert-end)
  443.         (recenter (/ (window-height) 2)))
  444.         ;; If that pushed message start off the frame,
  445.         ;; scroll to start it at the top of the frame.
  446.         (move-to-window-line 0)
  447.         (if (> (point) pos)
  448.         (progn
  449.           (goto-char pos)
  450.           (recenter 0))))
  451.       (message (or message (gettext "Type %s to continue editing."))
  452.            (single-key-description exit-char))
  453.       (let ((event (save-excursion (next-command-event))))
  454.         (or (eq (event-to-character event) exit-char)
  455.         (setq unread-command-event event))))
  456.       (if insert-end
  457.       (save-excursion
  458.         (delete-region pos insert-end)))
  459.       (setq buffer-file-name name)
  460.       (set-buffer-modified-p modified))))
  461.  
  462. ;;; cmdloop.el ends here
  463.